home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / knownfiddle.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.8 KB  |  121 lines
  1. structure KnownFiddle : sig val fiddle: CPS.function -> CPS.function end =
  2.  
  3. (*  This is a transformation of the CPS to be made just before the
  4.     closure phase.  If there is a FIX defining function g,
  5.     where the body of g calls the known function f defined outside of the
  6.     FIX, then we will add to the list of functions defined by the
  7.     fix an inverse-eta-reduction of f.
  8.  
  9.     Thus:
  10.  
  11.  
  12.     e as FIX([ ... (g,_, ... APP(f,...)...), ... ], ...)    where f free in e
  13.  
  14.                  rewrites to
  15.  
  16.     FIX([ ... (g,_, ... APP(f',...) ...), ..., (f',vl',APP(f,vl')) ], ...)
  17.  
  18.     The purpose of this is to improve the code generated by the
  19.     closure transformation.  In particular, if the APP(f,...) were in
  20.     a BRANCH or other control flow such that g did not always execute
  21.     it, then the closure module would normally make all the free variables
  22.     of f into extra arguments of g (normally by fetching them from
  23.     an appropriate closure).  This way, fetching the free variables of
  24.     f from the closure is delayed until the actual call of f, which is
  25.     a win if f is not always called.
  26.  
  27.  *)
  28.  
  29. struct
  30.  
  31.   open CPS Access 
  32.  
  33.  fun pass1 cexp : lvar -> lvar list =
  34.      (* The result of pass1 is a map showing, for each FIX labelled
  35.         by the name of its first-defined function, the set of
  36.     functions (known or otherwise) in function position within
  37.     the bodies of all functions defined by that FIX. 
  38.      *)
  39.    let exception Amap
  40.        val amap : lvar list Intmap.intmap = Intmap.new(32,Amap)
  41.        val note_applied = Intmap.add amap
  42.        val rec applied =
  43.      fn APP(VAR v,args) => [v]
  44.       | APP _ => []
  45.       | SWITCH(v,c,l) => SortedList.foldmerge(map applied l)
  46.       | RECORD(_,l,w,ce) => applied ce
  47.       | SELECT(_,v,w,ce) => applied ce
  48.       | OFFSET(_,v,w,ce) => applied ce
  49.       | SETTER(_,vl,e) => applied e
  50.       | LOOKER(_,vl,w,e) => applied e
  51.       | ARITH(_,vl,w,e) => applied e
  52.       | PURE(_,vl,w,e) => applied e
  53.       | BRANCH(_,vl,c,e1,e2) => SortedList.merge(applied e1, applied e2)
  54.       | FIX(nil,e) => applied e
  55.       | FIX(fl as (f,_,_)::_, e) =>
  56.         let val body_applied = 
  57.                 SortedList.foldmerge(map (fn (f,vl,b) => applied b) fl)
  58.          in note_applied (f, body_applied);
  59.             SortedList.merge(body_applied, applied e)
  60.         end
  61.   in applied cexp;
  62.      Intmap.map amap
  63.  end
  64.  
  65.  fun fiddle (func,args,cexp) =
  66.   let open IntmapF
  67.  
  68.       val applies = pass1 cexp
  69.  
  70.       fun rewrite_with (rename_map,knowns) =
  71.        let val rename = IntmapF.lookup rename_map
  72.        val rec rewrite =
  73.      fn e as APP(VAR v,args) => (APP(VAR(rename v),args) 
  74.                                  handle IntmapF => e)
  75.       | e as APP _ => e
  76.       | SWITCH(v,c,l) => SWITCH(v,c,map rewrite l)
  77.       | RECORD(k,l,w,ce) => RECORD(k,l,w, rewrite ce)
  78.       | SELECT(i,v,w,ce) => SELECT(i,v,w, rewrite ce)
  79.       | OFFSET(i,v,w,ce) => OFFSET(i,v,w, rewrite ce)
  80.       | SETTER(p,vl,e) => SETTER(p,vl, rewrite e)
  81.       | LOOKER(p,vl,w,e) => LOOKER(p,vl,w, rewrite e)
  82.       | ARITH(p,vl,w,e) => ARITH(p,vl,w, rewrite e)
  83.       | PURE(p,vl,w,e) => PURE(p,vl,w, rewrite e)
  84.       | BRANCH(p,vl,c,e1,e2) => BRANCH(p,vl,c, rewrite e1, rewrite e2)
  85.       | FIX(nil,e) => rewrite e
  86.       | FIX(fl as (f,_,_)::_, e) =>
  87.         let 
  88.         fun test(v::rest) = ((v, lookup knowns v) :: test rest
  89.                              handle IntmapF => test rest)
  90.           | test nil = nil
  91.  
  92.         fun redefine (f,vl) = 
  93.                    let val f'::vl' = map dupLvar (f::vl)
  94.                     in (f',vl',APP(VAR f, map VAR vl'))
  95.                end
  96.  
  97.         val newdefs = map redefine (test (applies f))
  98.           
  99.         val rename_map' = 
  100.             fold (fn ((f',_,APP(VAR f, _)),m) => add(m,f,f')) 
  101.                  newdefs
  102.              rename_map
  103.  
  104.         val knowns' = fold (fn ((f,vl,b),kn) => add(kn,f,vl)) fl knowns
  105.  
  106.         fun rewrite_body(f,vl,b) = 
  107.                (f,vl, rewrite_with(rename_map',knowns') b)
  108.  
  109.          in FIX(map rewrite_body fl @ newdefs, 
  110.             rewrite_with(rename_map, knowns') e)
  111.         end
  112.     in rewrite
  113.        end
  114.  
  115.   in (func, args, rewrite_with(empty,empty) cexp)
  116.  end
  117.  
  118.  
  119. end
  120.  
  121.